#|_____________________________________________________________________
 |                                                                     |
 | menufunc.lsp                                                        |
 | MENU CLOANER, MENUBAR, MENUSTRIP, FULLSCREEN, EXPLODE, SHAZAM       |
 | Copyright (c) 1991-2002 by Forrest W. Young                         |
 |_____________________________________________________________________|  
 |#


#|
;ORIGINAL LUKE TIERNEY VERSION
;(defmeth menu-proto :update ()
;  (let* ((items (send self :items)))
;    (mapcar #'(lambda (item) (send item :update)) items)))



FOLLOWING CODE PREVENTED UPDATING OF NON-CLOANED MENU ITEMS
  AND DID NOT UPDATE TITLE, KEY AND ACTION OF CLOANED MENU ITEMS

(defmeth menu-proto :update () (send self :update-items-of-cloaned-menu))

(defmeth menu-proto :update-items-of-cloaned-menu ()
  (let* ((cloaned-items (send self :items))
         (original-item)
         )
    (mapcar #'(lambda (cloaned-item)
                (when (send cloaned-item :has-slot 'original-item)
                      (setf original-item 
                            (send cloaned-item :slot-value 'original-item))
                      (send cloaned-item :enabled (send original-item :enabled))
                      (send cloaned-item :mark (send original-item :mark))))
            cloaned-items)))

;REPLACED BY CORRECTED FWY VERSION JAN 1 2003 
|#

;(defmeth menu-proto :update-items-of-cloaned-menu ()
;  (send self :update))

(defmeth menu-proto :popup-menu (x y &optional window)
  (send self :update)
  (send self :popup x y window))

(defmeth menu-proto :update ()
  (let* ((items (send self :items))
         (original-item))
    (mapcar #'(lambda (item)
                (cond
                  ((send item :has-slot 'original-item)
                   (setf original-item (send item :slot-value 'original-item))
                   (send item :title   (send original-item :title))
                   (send item :key     (send original-item :key))
                   (send item :enabled (send original-item :enabled))
                   (send item :mark    (send original-item :mark))
                   (send item :action  (send original-item :action))
                   )
                  (t
                   (send item :update))))
            items)))
                
(defun menu-cloaner (menu)
  (eval `(send ,(first (send menu :parents))
               :new ,(send menu :title))))

(defun menu-items-cloaner (menu)
  (items-cloaner (send menu :items)))

(defun items-cloaner (items)
  (let* ((new-item))
    (unless (listp items) (setf items (list items)))
    (mapcar #'(lambda (item)
                (cond
                  ((equal dash-item-proto (first (send item :parents)))
                   (send dash-item-proto :new))
                  (t
                   (setf new-item
                         (eval `(send ,(first (send item :parents))
                                      :new ,(send item :title)
                                      :mark ,(send item :mark)
                                      :enabled ,(send item :enabled)
                                      :action ',(send item :action))))
                   (send new-item :add-slot 'original-item  item)
                   (defmeth new-item :original-item (&optional (objid nil objid?))
                     (if objid? (setf (slot-value 'original-item) objid))	
                     (slot-value 'original-item))
                   (defmeth new-item :update (&rest args)
                     (let* ((item (send self :original-item)))
                       (send self :mark (send item :mark))
                       (send self :enabled (send item :enabled))))
                   new-item)))
            items)))

(defun cloan-menu (menu &optional (selection-list))
  (let* ((menu-cloan (menu-cloaner menu))
         (menu-item-cloans (menu-items-cloaner menu))
         (selection-list (if selection-list selection-list 
                             (iseq (length menu-item-cloans))))
         )
    (apply #'send menu-cloan :append-items (select menu-item-cloans selection-list))
    menu-cloan))

(defun make-datasheet-data-menu ()
  (let* ((menu-cloan (menu-cloaner *data-menu*))
         (menu-item-cloans 
          (items-cloaner
           (list 
            about-data-menu-item
            data-header-menu-item
            visualize-data-menu-item
            summarize-data-menu-item
            report-data-menu-item
            save-data-menu-item 
            export-data-file-menu-item
            print-data-menu-item 
            print-datastep-code-menu-item))))
    (apply #'send menu-cloan :append-items
           (combine
            (select menu-item-cloans (list 0 1))
            (send dash-item-proto :new)
            (select menu-item-cloans (list 2 3 4))
            (send dash-item-proto :new)
            (select menu-item-cloans (list 5 6))
            (send dash-item-proto :new)
            (select menu-item-cloans (list 7 8))))
    menu-cloan))
#|______________________________________________
 |
 | MENUBAR
 |______________________________________________
 |# 


(setf *menubar* nil)
(setf *floating-menubar* nil)
(setf *fullscreen-menubar* nil)

(defun floating-menubar ()
  (menubar))

(defun fullscreen-menubar ()
  (menubar :in "full"))


(setf *main-menubar* nil)
(defun main-menubar ()
  (menubar :in nil))

(defun menubar (&key (in nil in?) (toolwindow t) (length nil) (location '(100 200)) (strip nil))
"Args: (&key (in nil in?) (toolwindow t) (location '(100 200))
Creates menubar in container IN. If IN is not used, the menubar is a floating menubar (i.e., it is not in any window). If IN is bound to \"full\" the menubar is a not in any window, and is located at the top of the screen with a width equal to the screen width. If IN is explicitly set to NIL, the menubar is in in the XLispStat window. If IN is bound to an existing container, the menubar appears in that container. Appears at location LOCATION unless IN is \"full\"."
  (let* ((prev-container *active-container*)
         (mb) (menus)
         (size (if strip
                   (if *devel-mode* '(62 210) '(62 190))
                   (if length (list length 14)
                       (if *devel-mode* '(550 14) '(444 14)))))
         )
    (cond
      ((and (stringp in) (equal (string-downcase in) "full"))
       (setf size (list (first (screen-size)) 13))
       (setf mb (container :in nil :localmenu t :toolwindow toolwindow
                           :title "FullScreen MenuBar" 
                           :size size
                           :location '(0 3)))
       (setf *fullscreen-menubar* mb)
       (send *fullscreen-menubar* :location 0 3))
      ((and (not in) in?) 
       (setf mb (disable-container)))
      ((not in)
       (setf mb (container :in nil :localmenu t :toolwindow t 
                           :title "Floating MenuBar" 
                           :size size :location  location))
       (send mb :top-most t)
       (send mb :bottom-most nil)
       (setf *floating-menubar* mb))
      (t
       (setf mb (container :in in  :localmenu t :toolwindow t 
                           :title "MenuBar" 
                           :size size))))
    (setf *menubar* mb)
    (send *menubar* :add-slot 'menus (add-menubar))
    (enable-container prev-container)
    (defmeth *menubar* :menus (&optional (string nil set))
      (if set (setf (slot-value 'menus) string))
      (slot-value 'menus))
    (defmeth *menubar* :resize ()
      (apply #'send self :size size))
    (cond
      ((and (stringp in) (equal (string-downcase in) "full"))
       (send (select (send *desktop-menubar-menu* :items) 7) :title "Full Screen Off")
       (defmeth *menubar* :close ())
       (defmeth *menubar* :remove ()
         (call-next-method)
         (setf *fullscreen-menubar* nil)))
      (t
       (defmeth *menubar* :close ()
         (call-next-method)
         (setf *menubar* nil))))
    (send mb :top-most t)
    (send mb :bottom-most nil)
    mb))

(defun add-menubar-to-mainwindow ()
  (disable-container) 
  (send *file-menu* :remove)
  (send *edit-menu* :remove)
  (add-menubar :mainwindow t)
  )

(defun add-menubar-to-datasheet (&key (datasheet))
  (let ((prev-container *active-container*))
    (when container (enable-container container))
    (let* ((menu-list 
            (list
             (setf *window-menubar-menu* (cloan-menu *desktop-window-menu*))
             (setf *file-menubar-menu*    (cloan-menu *vista-file-menu*))
             (setf *edit-menubar-menu*    (cloan-menu *edit-menu*))
             (setf *data-menubar-menu*    (cloan-menu *data-menu*))
             (setf *trans-menubar-menu*   (cloan-menu *trans-menu*))
             (setf *tools-menubar-menu*   (cloan-menu *tools-menu*))
             (setf *model-menubar-menu*   (cloan-menu *model-menu*))
             (setf *command-menubar-menu* (cloan-menu *command-menu*))
             (setf *help-menubar-menu*    (cloan-menu *help-menu*))
             (setf *desktop-menubar-menu* (cloan-menu *desktop-desktop-menu*))
             )))
      (if mainwindow (send *window-menubar-menu* :title "View"))
      (setf menu-list (remove 'nil menu-list))
      (mapcar #'(lambda (menu)
                  (send menu :install))
              menu-list)
      menu-list)))                                        


(defun add-menubar (&key (container nil) (mainwindow nil))
  (let ((prev-container *active-container*))
    (when container (enable-container container))
    (let* ((menu-list 
            (list
             (setf *window-menubar-menu* (cloan-menu *desktop-window-menu*))
             (setf *file-menubar-menu* (cloan-menu *vista-file-menu*))
             (setf *edit-menubar-menu* (cloan-menu *edit-menu*))
             (setf *data-menubar-menu* (cloan-menu *data-menu*))
             (if *devel-mode* (setf *graphics-menubar-menu* 
                                    (cloan-menu *graphics-menu*)))
             (setf *trans-menubar-menu* (cloan-menu *trans-menu*))
             (setf *tools-menubar-menu* (cloan-menu *tools-menu*))
             (setf *model-menubar-menu* (cloan-menu *model-menu*))
             (setf *command-menubar-menu* (cloan-menu *command-menu*))
             (setf *help-menubar-menu* (cloan-menu *help-menu*))
             (if *devel-mode* (setf *devel-menubar-menu* (cloan-menu *devel-menu*)))
             (setf *desktop-menubar-menu* (cloan-menu *desktop-desktop-menu*))
             )))
      (if mainwindow (send *window-menubar-menu* :title "View"))
      (setf menu-list (remove 'nil menu-list))
      (mapcar #'(lambda (menu)
                  (send menu :install))
              menu-list)
      menu-list)))        

#|______________________________________________
 |
 | MENUSTRIP
 |______________________________________________
 |# 


(defun menustrip (&key (location '(0 0)) (go-away t))
"Args: (&key (location '(0 0)) (go-away t))
Presents a menuscript (a vertically-oriented menubar) a specified location. The close box may be made inoperable by specifying GO-AWAY NIL."
     (let ((oldmbar *Menubar*)
           (h (if *devel-mode* 230 190)))
       (setf *menustrip* (menubar :location location :strip t))
       (setf *menubar* oldmbar)
       (send *menustrip* :size 62 h)
       (send *menustrip* :title "Strip")
       (defmeth *menustrip* :size (&rest args) (apply #'call-next-method '(62 h)))
       (defmeth *menustrip* :resize () (send *menustrip* :size))
       (unless go-away (defmeth *menustrip* :close ()))
       (apply #'send *menustrip* :frame-location location)
       (send *menustrip* :resize)
       (send *menustrip* :top-most t)
       (send *menustrip* :bottom-most nil)
       (defmeth *menustrip* :do-motion (&rest args) (send self :active-window))
       ;(send *menustrip* :no-move t)
       *menustrip*
       ))

#|______________________________________________
 |
 | FULLSCREEN
 |______________________________________________
 |# 



(defun full-screen-desktop ()
  (cond
    ((not *full-screen-desktop*)
     (setf *restore-desktop-values* (get-seven-values))
     (setf *full-screen-desktop* t)
     (let* ((prev-container *active-container*)
            (dt *desktop-container*))
       (send *desktop-container* :has-v-scroll nil)
       (send *desktop-container* :has-h-scroll nil)
       (send  *desktop-container* :frame-location -4 -24)
       (apply #'send *desktop-container* :size (effective-screen-size))
       (defmeth *desktop-container* :resize ()
         (send  *desktop-container* :frame-location -4 -24)
	 (apply #'send *desktop-container* :size (effective-screen-size))
         (apply #'send *listener* :size (+ '(0 20) (send *listener* :size)))
	 )
       (send *full-screen-menu-item* :mark t)
       (send *desktop-container* :resize)
       (enable-container prev-container)
       t))
    (t
     (setf *full-screen-desktop* nil)
     (send *desktop-container* :make-desktop-container-resize)
     (send *full-screen-menu-item* :mark nil)
     (apply #'set-seven-values *restore-desktop-values*)
     (use-seven-values)
     (set-default-seven-values)
    ;(default-desktop)
     nil)))

;(listeners)

#|______________________________________________
 |
 | EXPLODE DESKTOP
 |______________________________________________
 |# 


(setf *EXPLODED-DESKTOP* nil)
(setf *DESKTOP-MENUBAR-MENU-ITEMS* nil)
(setf *EXPLODED-DESKTOP-MENUBAR-MENU-ITEMS* nil)
(setf *exploded-desktop-menu* nil)
(setf *unexploded-seven-values* *seven-values*)


(defun implode-desktop ()
  (explode-implode-toggle nil))

(defun explode-desktop ()
  (explode-implode-toggle))

(defun explode-implode-toggle (&optional (exim nil exim?))
  (if exim?
      (if exim (explode-the-desktop) (implode-the-desktop))
      (if *exploded-desktop* (implode-the-desktop) (explode-the-desktop)))
  *exploded-desktop*)
  
(defun implode-the-desktop ()
  (setf *exploded-desktop* nil)
  (defmeth *desktop-container* :resize () (call-next-method))
  (send *desktop-container* :make-desktop-container-resize)
  (send *desktop-container* :resize)
  (apply #'send *desktop-container* :location (select *unexploded-seven-values* '(2 3)))
  (mapcar #'(lambda (window)
              (send window :no-move t)
              (send window :pop-out nil)
              (send window :location 2000 2000))
          (list *workmap* *selector*))
  (apply #'send *desktop-container* :size (select *unexploded-seven-values* '(0 1)))
  (send *desktop-container* :front-window)
  (send *desktop-container* :change-desktop-menu nil)
  *exploded-desktop*)


(defun explode-the-desktop ()
  (restore-layout)
  (setf *unexploded-seven-values* (get-seven-values))
  (setf *exploded-menubar* *desktop-container*)
  (send *exploded-menubar* :top-most t)
  (send *exploded-menubar* :bottom-most nil)
  (mapcar #'(lambda (window)
              (send window :no-move nil)
              (apply #'send window :frame-location 
                     (+ '(-4 24) 
                        (send *exploded-menubar* :frame-location) 
                        (send window :location)))
              (send window :pop-out t)
              )
          (list *workmap* *selector* ))
  (apply #'send *workmap* :frame-size (- (send *workmap* :frame-size) '(0 12)))
  (send *selector* :frame-location 
        (+ 6 (first (send *selector* :frame-location)))
        (second (send *selector* :frame-location)))
  (send *selector* :frame-size 
        (+ 0 (first (send *selector* :frame-size)))
        (- (second (send *selector* :frame-size)) 12))
  (send *listener* :no-move nil)
  (apply #'send *listener* :frame-location 
         (+ (send *listener* :frame-location) '(-4 18);-4 24
            (send *desktop-container* :location)))
  (apply #'send *listener* :frame-size 
         (+ (send *listener* :frame-size) '(6 0)))
  (defmeth *exploded-menubar* :resize () 
    (send *exploded-menubar* :size 
          (first (send *exploded-menubar* :size)) 16))
  (send *listener* :pop-out t)
  (send *exploded-menubar* :resize)
  (send *exploded-menubar* :top-most nil)
  (send *workmap* :top-most nil)
  (send *selector* :top-most nil)
  (setf *exploded-desktop* t)
  (send *desktop-container* :change-desktop-menu t)
  )


(defmeth container-proto :change-desktop-menu (exploded-desktop)
  (unless *desktop-menubar-menu-items*
          (setf *desktop-menubar-menu-items*
                (send *desktop-desktop-menu* :items)))
  (unless *exploded-desktop-menubar-menu-items*
          (setf *exploded-desktop-menubar-menu-items*
                (list (send expert-menu-item-proto :new "Show WorkMap" :enabled t
                            :action #'(lambda () (send *workmap* :front-window)))
                      (send expert-menu-item-proto :new "Show Selector" :enabled t
                            :action #'(lambda () (send *varobs-obj* :front-window)))
                      (send expert-menu-item-proto :new "Show Listener" :enabled t
                            :action #'(lambda () (send *listener* :front-window))))))
  (apply #'send *desktop-desktop-menu* :delete-items 
         (send *desktop-desktop-menu* :items))
  (cond 
    (exploded-desktop
     (apply #'send *desktop-desktop-menu* :append-items
            (combine *exploded-desktop-menubar-menu-items*
                     (select *desktop-menubar-menu-items* 
                             (iseq 3 (1- (length *desktop-menubar-menu-items* )))))))
    (t
     (apply #'send *desktop-desktop-menu* :append-items
            *desktop-menubar-menu-items*)))
  
  (send *explode-desktop-menu-item* :title 
        (if exploded-desktop "Implode DeskTop" "Explode DeskTop"))

  (send command-menu-hide-desktop-item :enabled (not exploded-desktop))
  (send *full-screen-menu-item* :enabled (not exploded-desktop))
  t)



(defmeth container-proto :exploded-window-close-menu ()
  (mapcar #'(lambda (window)
              (defmeth window :close ()
                (let* ((x (first (+ (send window :location)
                                    (send window :size))))
                       (y (second (send window  :location)))
                       (menu (send menu-proto :new "Close"))
                       )
                  (send menu :append-items
                        (send menu-item-proto :new "Hide Window"
                              :action #'(lambda () 
                                          (send window :hide-window)))
                        (send menu-item-proto :new "Exit ViSta"
                              :action #'vista-exit))
                  (send menu :install)
                  (send menu :popup x y window))
              )
          (list *workmap* *selector* *datasheet* *listener*))))
    
  


#|______________________________________________
 |
 | SHAZAM
 |______________________________________________
 |# 


(setf *shazam* t)

(defun shazam ()
  (cond 
    (*shazam*
     (flet ((targloc ()
                     (let* ((rand (* 2 (- (uniform-rand 2) (list .5 .5))))
                            (minrand (min rand))
                            (minone (/ rand minrand))
                            (maxscreen (max (screen-size))))
                       (* maxscreen minone))))
       (let* ((plots (list *workmap* *selector* *listener*))
              (startlocs (mapcar #'(lambda (plot) (send plot :location)) plots))
              (targlocs (mapcar #'(lambda (i) (targloc)) (iseq 3)))
              (num 40)
              )
         (setf *shazam-locs* startlocs)
         
         (mapcar #'(lambda (plot) 
                     (send plot :pop-out t)) 
                 plots)
         (dotimes (i num)
                  (mapcar #'(lambda (plot targloc startloc)
                              (print targloc) (print startloc)
                              (apply #'send plot :location 
                                     (floor (+ startloc (* (/ i num) (- targloc startloc)))))
                              )
                          plots targlocs startlocs))))
     (setf *shazam-desk-size* (send *desktop-container* :size))
     (send *desktop-container* :hide-window)
     (setf *shazam-menubar* (menubar))
     (setf *shazam* nil))
    (t
     (send *desktop-container* :show-window)
     (send *shazam-menubar* :close)
     (apply #'send *desktop-container* :size *shazam-desk-size*)
     (mapcar #'(lambda (plot) 
                     (send plot :pop-out nil))
             (list *workmap* *selector* *listener*))
     (setf *shazam* t))))
